home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / CHFLZ100.ZIP / LZ.PAS < prev    next >
Pascal/Delphi Source File  |  1996-09-05  |  14KB  |  535 lines
  1. {
  2. SAMPLE PROGRAM TO DEMONSTRATE THE USE OF THE CHIEFLZ v1.00 PACKAGE.
  3. THIS PROGRAM WILL COMPILE FOR THE FOLLOWING PLATFORMS;
  4.      Dos Real mode - TP7, BP7
  5.      Dos DPMI      - BP7, BPW
  6.      Win16         - BPW, TPW, Delphi 1.x
  7.      Win32         - Delphi 2.0x
  8. }
  9.  
  10. Program LZ;
  11.  
  12. {$I LZDefine.inc}
  13.  
  14. {this (aDLL) is now defined (or not) in LZDEFINE.INC}
  15. {$ifdef aDLL}
  16.   {$define ExplicitLink}  {use explicit linking of DLL}
  17. {$endif aDLL}
  18.  
  19. {$ifdef Windows}
  20. {$ifdef Win32}
  21.   {$MINSTACKSIZE $00004000}
  22.   {$MAXSTACKSIZE $00100000}
  23.   {$IMAGEBASE    $00400000}
  24.   {$APPTYPE      Console}
  25. {$else Win32}
  26.   {$M 20000, 1024}
  27.   {$F+}        { Force Far-Calls }
  28.   {$K+}        { Use smart call-backs for LZReport, etc. }
  29. {$endif Win32}
  30. {$endif Windows}
  31.  
  32. {$ifdef Delphi}
  33. {
  34.   Link in the Delphi-generated resource file ...
  35. }
  36.   {$R *.RES}
  37. {$endif Delphi}
  38.  
  39. Uses
  40. {$ifdef Win32}
  41.  {$ifdef aDLL}
  42.   ShareMem,                   { ChiefLZ.DLL exports long-strings ...!!! }
  43.   {$ifdef ExplicitLink}
  44.   LZExplic in 'LZExplic.pas',
  45.   {$else ExplicitLink}
  46.   LZImplic in 'LZImplic.pas',
  47.   {$endif ExplicitLink}
  48.   {$else aDLL}
  49.   ChiefLZ in 'ChiefLZ.pas',
  50.   {$endif aDLL}
  51. {$else Win32}
  52.  {$ifdef aDLL}
  53.   {$ifdef ExplicitLink}
  54.   LZExplic,
  55.   {$else ExplicitLink}
  56.   LZImplic,
  57.   {$endif ExplicitLink}
  58.  {$else aDLL}
  59.   ChiefLZ,
  60.  {$endif aDLL}
  61. {$endif Win32}
  62.  
  63. {$ifdef Delphi}
  64.   SysUtils,
  65. {$endif Delphi}
  66. {$ifdef Win32}
  67.   Windows,
  68. {$else Win32}
  69. {$ifdef Windows}
  70. {$ifndef DPMI}
  71.   WinCRT,
  72. {$endif DPMI}
  73. {$ifndef Delphi}
  74.   WinDOS, Strings,
  75. {$endif Delphi}
  76. {$else Windows}
  77.   Dos, Strings,
  78. {$endif Windows}
  79. {$endif Win32}
  80.   ChfTypes,
  81.   ChfUtils;
  82.  
  83. VAR
  84. AutoReplaceAll: boolean;
  85.  
  86. {$ifdef Win32}
  87. procedure FlushInputBuffer;
  88. begin
  89.   FlushConsoleInputBuffer(GetStdHandle(STD_INPUT_HANDLE))
  90. end;
  91.  
  92. function ReadKey32: Char;
  93. var
  94.   NumRead:       Integer;
  95.   HConsoleInput: THandle;
  96.   InputRec:      TInputRecord;
  97. begin
  98.   HConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
  99.   while not ReadConsoleInput(HConsoleInput,
  100.                              InputRec,
  101.                              1,
  102.                              NumRead) or
  103.            (InputRec.EventType <> KEY_EVENT) do;
  104.   Result := InputRec.KeyEvent.AsciiChar
  105. end;
  106. {$endif Win32}
  107.  
  108. {$ifdef Delphi}
  109. function TimeToStr(const l: LongInt): string;
  110. begin
  111.   Result := FormatDateTime('dd/mm/yy  hh:nna/p',FileDateToDateTime(l))
  112. end;
  113. {$else}
  114. Function TimeToStr(Const L : Longint):String;
  115. Type
  116.   ElementStr = String[10];
  117.  
  118. procedure FormatElement(Num: word; var EStr: ElementStr);
  119. begin
  120.   Str(Num:2, EStr);
  121.   if Num < 10 then
  122.     EStr[1] := '0'
  123. end;
  124.  
  125. Var
  126. Result : String[25];
  127. {$ifdef Windows}
  128. Var
  129. T : TDateTime;
  130. {$else}
  131. Var
  132. T : DateTime;
  133. {$endif Windows}
  134. Var
  135. Dd,Mm,Yy,
  136. Hr,Min : ElementStr;
  137.  
  138. Begin
  139.    UnpackTime(L, T);
  140.    FormatElement(T.Day, Dd);
  141.    FormatElement(T.Month, Mm);
  142.    Str(T.Year:4, Yy);
  143.    FormatElement(T.Hour, Hr);
  144.    FormatElement(T.Min, Min);
  145.    Result := Dd+'/'+Mm+'/'+Yy+'  '+Hr+':'+Min{+':'+Sec};
  146.    TimeToStr := Result;
  147. End;
  148. {$endif Delphi}
  149. {------------------------------------------------------------}
  150.  
  151. {///////////////////////////////////////////}
  152. Function Confirm(const fRec: TLZReportRec; Const aDest:String):TLZReply;
  153. {$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
  154. {procedure to ask question if target file exists already}
  155. Var
  156. Ch:Char;
  157. Begin
  158.   if AutoReplaceAll then
  159.     begin
  160.       Confirm := LZYes;
  161.       Exit
  162.     end;
  163.  
  164.   With fRec
  165.   do begin
  166.     Writeln('Target File Exists!!!');
  167.     Writeln('File Name : ',Names);
  168.     Writeln('File Date : ',TimeToStr(Times));
  169.  
  170.     Writeln('Compressed: ',Sizes);
  171.     Writeln('Real Size : ',uSizes);
  172.     Writeln('Version   : ',FileVersion);
  173.   End;
  174.  
  175.   Repeat
  176.     Write('OVERWRITE FILE : ', aDest, ' ? (Yes/No/All/Quit) [Y/N/A/Q] : ');
  177.     Readln(Ch);
  178.   Until Upcase(Ch) in ['Y','N','A','Q'];
  179.   Case UpCase(Ch) of
  180.   'A' : begin
  181.           Confirm := LZYes;
  182.           AutoReplaceAll := True {overwrite all others}
  183.         end;
  184.   'N' : begin
  185.            Confirm := LZNo;
  186.            Writeln('Skipping file  : ',aDest)
  187.         end;
  188.   'Q' : Confirm := LZQuit { stop all processing and Exit }
  189.   else
  190.     Confirm := LZYes { Ch = 'Y' }
  191.   End; {Case}
  192. End;
  193. {///////////////////////////////////////////}
  194.  
  195. Procedure DeMyRep(Const aName: TLZReportRec{String}; Const aSize: Longint);
  196. {$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
  197. {procedure to show progress}
  198. Begin
  199.    if (Length(aName.Names) > 0) and (aSize=-1) then
  200.      Write('Processing file: ',aName.Names,' ')
  201.    else if (asize=-2) then
  202.      Writeln
  203.    else if aSize > 0 then
  204.      Write('.')
  205. End;
  206.  
  207. {-----------------------------------------------}
  208. function MyRename(var FName: string): boolean;
  209. {$ifdef Win16} {$ifdef aDLL} export {$else} far {$endif}; {$endif}
  210. var
  211.   Ch: Char;
  212. {$ifndef Delphi}
  213. var Result: boolean;
  214. {$endif}
  215. begin
  216.   Write( 'Cannot overwrite ', FName, ' - Rename? [Y/N]' );
  217.   Readln(Ch);
  218.   Result := UpCase(Ch) = 'Y';
  219.   if Result then
  220.     begin
  221.       Write( 'New name: ' );
  222.       Readln(FName)
  223.     end;
  224. {$ifndef Delphi}
  225.   MyRename := Result
  226. {$endif}
  227. end;
  228.  
  229. {-----------------------------------------------}
  230. Procedure Syntax;
  231. Begin
  232.   Writeln('LZSS Compressor: by Dr A Olowofoyeku (the African Chief), and Chris Rankin.');
  233.   writeln;
  234.   WriteLn('Usage: LZ <InSpec> [OutSpec] [[/U /A[/R[1]] /X /V]]');
  235.   Writeln;
  236.   Writeln('no switch  =  compress a single file (InSpec) to OutSpec');
  237.   Writeln('e.g.          LZ BIG.EXE SMALL.LZZ');
  238.   Writeln;
  239.   Writeln(' /U        =  decompress a single file (InSpec) to OutSpec');
  240.   Writeln(' e.g.         LZ SMALL.LZZ BIG.EXE /U');
  241.   Writeln('');
  242.  
  243.   Writeln(' /A        =  compress and archive the files (InSpec) into archive (OutSpec)');
  244.   Writeln('e.g.          LZ C:\TEMP\*.* TEMP.LZZ /A');
  245.   Writeln('              Max = ' + {$ifdef Win32} '2048'
  246.                                    {$else}        '600'
  247.                                    {$endif} + ' files in archive');
  248.   Writeln;
  249.  
  250.   Writeln(' /R        =  recurse through directory structure (for archives)');
  251.   Writeln(' /R1       =  recurse into 1st level directories (for archives)');
  252.   Writeln('e.g.          LZ C:\TEMP\*.* TEMP.LZZ /A /R');
  253.   Writeln;
  254.  
  255.   Writeln(' /X        =  decompress an LZ archive (InSpec) into directory (OutSpec)');
  256.   Writeln('e.g.          LZ TEMP.LZZ C:\TEMP /X');
  257.   Writeln;
  258.  
  259.  
  260.   Writeln(' /V        =  show contents of an LZ archive (InSpec)');
  261.   Writeln('e.g.          LZ TEMP.LZZ /V');
  262.  
  263.   {$ifdef Windows}
  264.    {$ifdef Win32}
  265. {
  266.     FlushInputBuffer;  // Use these if running within IDE to
  267.     ReadKey32;         // prevent console window from disappearing
  268. }
  269.    {$else}
  270.    {$ifndef DPMI}
  271.     ReadKey;
  272.     DoneWincrt;
  273.     {$endif DPMI}
  274.    {$endif Win32}
  275.   {$endif Windows}
  276.  
  277.   Halt(1);
  278. End;
  279.  
  280. {-----------------------------------------------}
  281. {$ifNdef aDLL}
  282. {example of using the LZ object}
  283. Procedure UseObj;
  284. Var
  285. o:LZObj;
  286. l:longint;
  287. Param:string;
  288. Begin
  289.    o {$ifdef Delphi} := LZObj.Create
  290.      {$else} .Init
  291.      {$endif}(ParamStr(1),ParamStr(2));
  292.    {$ifdef Delphi}
  293.    try
  294.    o.QuestionProc := Confirm;
  295.    o.ReportProc := DeMyRep;
  296.    {$else}
  297.    o.SetQuestionProc(Confirm);
  298.    o.SetReportProc(DeMyRep);
  299.    {$endif}
  300.    Param := Uppercase(ParamStr(3));
  301.    if (Param='/U') or (Param='-U') then
  302.      l:=o.Decompress
  303.    else
  304.      l:=o.Compress;
  305.  {$ifdef Delphi}
  306.    finally
  307.      o.Free
  308.    end;
  309.  {$else}
  310.    o.Done;
  311.  {$endif}
  312.    Writeln(l);
  313.    Halt;
  314. End;
  315. {$Endif aDLL}
  316.  
  317. {///////////////////////////////////////////}
  318. function GetCompressionRatio(const Comp, Orig: LongInt): LongInt;
  319. begin
  320.   if Orig = 0 then
  321.     GetCompressionRatio := 0  { 0%, on the grounds that the file }
  322.   else                        { is still its original size ...   }
  323.     GetCompressionRatio := 100 - ( (100*Comp) div Orig )
  324. end;
  325.  
  326. {///////////////////////////////////////////}
  327. {///////////////////////////////////////////}
  328. {///////////////////////////////////////////}
  329. {///////////////////////////////////////////}
  330.  
  331. var
  332.   ReadProc,WriteProc,UserParam: TLZPathStr;
  333.   p: {$ifdef Win32} string;
  334.      {$else}        array[0..79] of Char;
  335.      {$endif}
  336.   i:integer;
  337.   j,k:longint;
  338.   X:PChiefLZArchiveHeader;
  339.   LZRecurseDirs: TLZRecurse;
  340.  
  341. Begin
  342.   {$ifdef Windows}
  343.    {$ifndef Win32}
  344.    {$ifndef DPMI}
  345.     StrPCopy(WindowTitle, 'Sample ChiefLZ program ');
  346.     ScreenSize.x:=80;
  347.     ScreenSize.y:=250;
  348.     WindowOrg.x := 1;
  349.     WindowOrg.y := 1;
  350.     {$endif DPMI}
  351.    {$endif Win32}
  352.   {$endif Windows}
  353.  
  354.   if ParamCount < 2 then
  355.   begin
  356.     Syntax;
  357.   end;
  358.   
  359.   {$ifdef ExplicitLink}
  360.      {$ifdef Win32}
  361.        if not LoadChiefLZDLL('') then
  362.          begin
  363.            Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
  364.            Halt
  365.          end;
  366.      {$else Win32}
  367.        i := LoadChiefLZDLL(''{'MYDLL.DLL'});
  368.        if i <> 0 then begin
  369.          Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
  370.          Writeln('Error Code : ',i);
  371.          Halt;
  372.        end;
  373.      {$endif Win32}
  374.        Writeln('ChiefLZ DLL loaded successfully. Its DLL handle is: ',GetChiefLZDLLHandle);
  375.        Writeln('Working now ... ');
  376.   {$endif ExplicitLink}
  377.  
  378. {
  379.   UseObj;
  380.   Halt;
  381. }  
  382.   ReadProc := ParamStr(1);
  383.   WriteProc := ParamStr(2);
  384.   UserParam := Uppercase(ParamStr(3));
  385.   AutoReplaceAll := False; {confirm for each file}
  386.  
  387.   if (Uppercase(ParamStr(2))='-V') or
  388.      (Uppercase(ParamStr(2))='/V') then begin
  389.  
  390.     if not IsChiefLZArchive({$ifdef Win32} ReadProc
  391.                             {$else}       @ReadProc[1]
  392.                             {$endif})
  393.     then begin
  394.         Writeln(ReadProc,' is not a ChiefLZ archive!');
  395.         {$ifdef ExplicitLink}
  396.         If UnloadChiefLZDLL
  397.         then Writeln('I have unloaded the ChiefLZ.DLL');
  398.         {$endif ExplicitLink}
  399.         Halt;
  400.     end;
  401.     New(X);
  402.   {$ifdef Win32}
  403.     try
  404.   {$endif}
  405.     GetChiefLZArchiveInfo({$ifdef Win32} ReadProc
  406.                           {$else Win32}  Str2PChar(ReadProc)
  407.                           {$endif Win32}, X^);
  408.     j:=0;k:=0;
  409.  
  410.     Writeln('ChiefLZ archive file: ',ReadProc);
  411.     Writeln('ChiefLZ archive size: ',
  412.               GetChiefLZArchiveSize({$ifdef Win32} ReadProc
  413.                                     {$else Win32}  Str2PChar(ReadProc)
  414.                                     {$endif Win32}),
  415.             ' bytes');
  416.  
  417.     Writeln('  Real Size   LZ Size  Ratio   Date      Time    Version   FileName');
  418.     Writeln('------------------------------------------------------------------');
  419.     for i := 1 to X^.Count do
  420.       with X^.Files[i] do
  421.         begin
  422.           inc(j, Sizes);
  423.           inc(k, uSizes);
  424.           If IsDir then
  425.             Write({ Names:13,}
  426.                    '<DIR>':10,
  427.                    0:10,
  428.                    0:6 )
  429.           else
  430.             Write( {Names:13,}
  431.                    uSizes:10,
  432.                    Sizes:10,
  433.                    GetCompressionRatio(Sizes,uSizes):6 );
  434.           Write( '%  ',
  435.                   TimeToStr(Times),
  436.                   '  ', FileVersion:8,
  437.                   '   ',GetFullLZName(X^,i) );
  438.           if IsDir then
  439.             Writeln('\')
  440.           else
  441.             Writeln
  442.  
  443.         end {for i};
  444.  
  445.       Writeln;
  446.       Writeln('Number of Files   = ',X^.Count);
  447.       Writeln('Compressed Size   = ',j,' bytes');
  448.       Writeln('Expanded Size     = ',k,' bytes');
  449.       Writeln('Compression Ratio = ', GetCompressionRatio(j,k),'%');
  450.  
  451.   {$ifdef Win32}
  452.     finally
  453.   {$endif}
  454.     Dispose(X);
  455.   {$ifdef Win32}
  456.     end
  457.   {$endif}
  458.   end
  459.  else
  460.   if (UserParam = '/X') or (UserParam = '-X') then begin
  461.      writeln(LZDearchive({$ifdef Win32} ReadProc, WriteProc,
  462.                          {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  463.                          {$endif} Confirm, DeMyRep, MyRename))
  464.   end else
  465.   if (UserParam = '/A') or (UserParam = '-A') then begin
  466.   
  467.      UserParam := Uppercase(ParamStr(ParamCount));
  468.      if (UserParam = '-R') or (UserParam = '/R') then
  469.        LZRecurseDirs := LZFullRecurse
  470.      else if (UserParam = '-R1') or (UserParam = '/R1') then
  471.        LZRecurseDirs := LZRecurseOnce
  472.      else
  473.        LZRecurseDirs := LZNoRecurse;
  474.  
  475.      writeln(LZArchive({$ifdef Win32} ReadProc, WriteProc
  476.                        {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc)
  477.                        {$endif}, LZRecurseDirs, DeMyRep))
  478.   end else
  479.   if (UserParam = '/U') or (UserParam = '-U') then
  480.   begin
  481.      writeln(LZDecompress({$ifdef Win32} ReadProc, WriteProc,
  482.                           {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  483.                           {$endif} Confirm, DemyRep));
  484.      {$ifdef Win32} p := GetChiefLZFileName(ReadProc);
  485.      {$else}        GetChiefLZFileName(Str2PChar(ReadProc), p);
  486.      {$endif}
  487.      Writeln('Filename in header: ',p);
  488.      writeln('FileSize in header: ',
  489.                   GetChiefLZFileSize({$ifdef Win32} ReadProc
  490.                                      {$else}        Str2PChar(ReadProc)
  491.                                      {$endif}) );
  492.   end
  493.   else
  494.   if ParamStr(2)= '/1' then begin
  495.     LZCompressEx({$ifdef Win32} ReadProc,
  496.                  {$else}        Str2PChar(ReadProc),
  497.                  {$endif} Confirm,DeMyRep);
  498.   end else
  499.   if ParamStr(2)= '/2' then begin
  500.     LZDecompressEx({$ifdef Win32} ReadProc,
  501.                    {$else}        Str2PChar(ReadProc),
  502.                    {$endif} Confirm,DeMyRep);
  503.   end
  504.   else begin
  505.      writeln(LZCompress({$ifdef Win32} ReadProc, WriteProc,
  506.                         {$else}        Str2PChar(ReadProc), Str2PChar(WriteProc),
  507.                         {$endif} Confirm, DeMyRep));
  508.   end;
  509.  
  510.   {$ifdef ExplicitLink}
  511.     Writeln;
  512.     If UnloadChiefLZDLL then
  513.       Writeln('I have successfully unloaded the ChiefLZ DLL')
  514.     else
  515.       Writeln('Error trying to unloaded the ChiefLZ DLL');
  516.     Writeln('Its DLL handle is: ',GetChiefLZDLLHandle);
  517.  
  518.   {$endif ExplicitLink}
  519.  
  520.   {$ifdef Windows}
  521.    {$ifdef Win32}
  522. {
  523.     FlushInputBuffer;  // Use these if running within the IDE
  524.     ReadKey32;         // to prevent console window disappearing
  525. }
  526.    {$else}
  527.    {$ifndef DPMI}
  528.     ReadKey;
  529.     DoneWincrt;
  530.     {$endif DPMI}
  531.    {$endif Win32}
  532.   {$endif Windows}
  533. End.
  534.  
  535.